home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gwuada_9.zip / 7.C < prev    next >
C/C++ Source or Header  |  1993-07-27  |  37KB  |  1,159 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "hdr.h"
  10. #include "libhdr.h"
  11. #include "vars.h"
  12. #include "setp.h"
  13. #include "errmsgp.h"
  14. #include "dclmapp.h"
  15. #include "libp.h"
  16. #include "miscp.h"
  17. #include "unitsp.h"
  18. #include "nodesp.h"
  19. #include "smiscp.h"
  20. #include "chapp.h"
  21. /* TBSL: check that check_priv_decl always called with first
  22.     argument (kind) as integer, corresponding to MISC_TYPE_ATTRIBUTE...
  23.  */
  24.  
  25. static int in_relevant_scopes(int);
  26. static Symbol trace_ancestor(Symbol, Tuple);
  27. static void private_part(Node);
  28.  
  29. void package_specification(Node node)    /*; package specification */
  30. {
  31.     Node    id_node, decl_node, priv_node;
  32.  
  33.     id_node   = N_AST1(node);
  34.     decl_node = N_AST2(node);
  35.     priv_node = N_AST3(node);
  36.     new_package(id_node, na_package_spec);
  37.     package_declarations(decl_node, priv_node);
  38.     end_specs(N_UNQ(id_node));
  39. }
  40.  
  41. void new_package(Node id_node, int nat)    /*;new_package*/
  42. {
  43.     /* Process a  package specification: install scope, initialize  mappings. */
  44.  
  45.     char    *id;
  46.     Symbol    ud;
  47.     int        body_number;
  48.  
  49.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  new_package");
  50.  
  51.     id = N_VAL(id_node);
  52.     new_compunit("sp", id_node);
  53.     if (nat==na_generic_part && IS_COMP_UNIT) {
  54.             /* allocate unit number for body, and mark it obsolete */
  55.             body_number = unit_number(strjoin("bo", id));
  56.             pUnits[body_number]->libInfo.obsolete = string_ds; /*"$D$"*/
  57.     }
  58.     newmod(id);
  59.  
  60.     N_UNQ(id_node) = scope_name;
  61.     NATURE(scope_name)  = nat;
  62.     TYPE_OF(scope_name) = symbol_none;
  63.     /* Create dummy entry to hold use clauses, which are declarative items.*/
  64.     find_new("$used");
  65.     /* use_declarations in SETL is signature(declared(scope_name), '$used') */
  66.     ud = dcl_get(DECLARED(scope_name), "$used");
  67.     SIGNATURE(ud) = tup_new(0);
  68.     private_decls(scope_name) = (Set) private_decls_new(0);
  69. }
  70.  
  71. void package_declarations(Node decl_node, Node priv_node)
  72.                                                     /*;package_declarations */
  73. {
  74.     char    *str;
  75.     Symbol    s1, u_name;
  76.     Fordeclared dcliv;
  77.  
  78.     adasem(decl_node);
  79.     /* The declarations so far constitute the visible part of the package*/
  80.     /* save current declarations */
  81.     /*    visible(scope_name) = declared(scope_name); */
  82.     FORDECLARED(str, s1, DECLARED(scope_name), dcliv);
  83.         IS_VISIBLE(dcliv) = TRUE;
  84.     ENDFORDECLARED(dcliv);
  85.  
  86.     FORDECLARED(str, u_name, DECLARED(scope_name), dcliv)
  87.         if (TYPE_OF(u_name) == symbol_incomplete) {
  88.         errmsg_id("missing full declaration for %", u_name, "3.8.1", decl_node);
  89.         }
  90.     ENDFORDECLARED(dcliv);
  91.     /* Now process private part of package.*/
  92.     private_part(priv_node);
  93. }
  94.  
  95. void module_body_id(int mod_nature, Node name_node)  /*;module_body_id*/
  96. {
  97.     /* This procedure is invoked when the name of a module body has been
  98.      * seen. It opens the new scope, and if necessary retrieves from the
  99.      * library the specifications for the module.
  100.      */
  101.  
  102.     Symbol    mod_name, c, real_t;
  103.     char    *spec_name;
  104.     int    nat, mattr, mark;
  105.     char    *id;
  106.     Symbol    s1, s2, t;
  107.     Fordeclared    fd1;
  108.     Forprivate_decls    fp1;
  109.     Private_declarations    pd;
  110.     Tuple    ud;
  111.     Symbol    uds; /* check tupe of this    ds 4 aug */
  112.     Fortup    ft1;
  113.  
  114.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  module_body_id");
  115.  
  116.     new_compunit("bo", name_node);
  117.  
  118.     find_old(name_node);
  119.     mod_name = N_UNQ(name_node);
  120.     if (!IS_COMP_UNIT && SCOPE_OF(mod_name) != scope_name) {
  121.         errmsg("Specification and body are in different scopes" , "7.1, 9.1",
  122.           name_node);
  123.     }
  124.  
  125.     /* Nature of specification must match that of current body*/
  126.  
  127.     /*
  128.      * const specs_of = { 
  129.      *     [na_package, {na_package_spec, na_generic_package_spec}],
  130.      *     [na_task_type, {na_task_type_spec, na_task_obj_spec}] };
  131.      * if (NATURE(mod_name) in specs_of(mod_nature) ) {
  132.      *     rmatch(nature(mod_name), '_spec');        $ not a spec any longer 
  133.      * }
  134.      */
  135.     nat = NATURE(mod_name);
  136.     if (mod_nature == na_package
  137.       && (nat == na_package_spec || nat == na_generic_package_spec)
  138.       || (mod_nature == na_task_type && (nat == na_task_type_spec
  139.       || nat == na_task_obj_spec 
  140.       || (nat == na_obj && NATURE(TYPE_OF(mod_name)) == na_task_type_spec)))) {
  141.         /* if the task appeared in a previously (separately) compiled unit,
  142.           * the expander has already changed its nature to na_obj
  143.           */
  144.         if (nat == na_package_spec) nat = na_package;
  145.         else if (nat == na_generic_package_spec)
  146.             nat = na_generic_package;
  147.         else if (nat == na_task_type_spec)
  148.             nat = na_task_type;
  149.         else if (nat == na_task_obj_spec)
  150.             nat = na_task_obj;
  151.         else if (nat == na_obj)
  152.             NATURE(TYPE_OF(mod_name)) = na_task_type;
  153.  
  154.         NATURE(mod_name) = nat;
  155.     }
  156.     else {
  157.         errmsg_nval("Matching specification not found for body %", name_node,
  158.           "7.1, 9.1", name_node);
  159.     }
  160.  
  161.     /* if module is a generic package body and the current unit is a package
  162.      * body, verify that the generic spec appeared in the same file.
  163.      */
  164.     if (NATURE(mod_name) == na_generic_package 
  165.       && streq(unit_name_type(unit_name), "bo")) {
  166.         if (is_subunit(unit_name))
  167.             spec_name = pUnits[stub_parent_get(unit_name)]->name;
  168.         else
  169.             spec_name = strjoin("sp", unit_name_name(unit_name));
  170.         if (!streq(lib_unit_get(spec_name), AISFILENAME))
  171.             errmsg("Separately compiled generics not supported", "none",
  172.               name_node);
  173.     }
  174.  
  175.     newscope (mod_name);    /* added to match SETL    gcs 23 jan */
  176.     if (private_decls(mod_name) == (Set)0)
  177.         private_decls(mod_name) = (Set) private_decls_new(0);
  178.     /* For safe processing of body.*/
  179.     if (DECLARED(mod_name) == (Declaredmap)0)
  180.         DECLARED(mod_name) = dcl_new(0);
  181.  
  182.     if (NATURE(mod_name) == na_task_type ) {
  183.         /* Within the body of a task type, the name of the task can be used 
  184.          * to designate the task currently executing the body. We create an 
  185.          * alias to be elaborated at run-time, under the name 'current_task'.
  186.          */
  187.         c = find_new(strjoin("", "current_task"));
  188.         TYPE_OF(c) = mod_name;
  189.         NATURE(c) = na_obj;
  190.     }
  191.     else if (NATURE(mod_name) == na_task_obj ) {
  192.         /* remove -spec marker from its anonymous task type as well.*/
  193.         NATURE(TYPE_OF(mod_name)) = na_task_type;
  194.     }
  195.     else if (mod_nature == na_package ) {
  196.         /* Within a package body, declarations from the private part of the
  197.          * specification are     visible. Swap    visible and  private versions.
  198.          */
  199.         pd = (Private_declarations) private_decls(mod_name);
  200.         FORPRIVATE_DECLS(s1, s2, pd, fp1);
  201.             private_decls_swap(s1, s2);
  202.         ENDFORPRIVATE_DECLS(fp1);
  203.         /* (forall [item, pdecl] in private_decls(mod_name))
  204.          * [SYMBTABF(item), private_decls(mod_name)(item)] :=
  205.          * [pdecl, SYMBTABF(item)];    
  206.          * end forall;
  207.          */
  208.         /* Furthermore, composite types that depend on (outer) private types
  209.          * may now be fully useable if the latter received full declarations,
  210.          * (as long as they do not depend in external private types...)
  211.          */
  212.         FORDECLARED(id, t, DECLARED(mod_name), fd1);
  213.             if (NATURE(t) == na_package_spec && !tup_mem((char *) t, vis_mods) )
  214.                 vis_mods = tup_with(vis_mods, (char *) t);
  215.             else if (! is_type(t)) continue;
  216.             mattr = (int) misc_type_attributes(t);
  217.             mark = 0;
  218.             if (mattr & TA_PRIVATE)
  219.                 mark = TA_PRIVATE;
  220.             else if (mattr & TA_LIMITED_PRIVATE)
  221.                 mark = TA_LIMITED_PRIVATE;
  222.             /* exclude the mark 'limited' from this test (gs apr 1 85) */
  223.             /* else if (mattr & TA_LIMITED)
  224.              * mark = TA_LIMITED;
  225.              */
  226.             else if (mattr & TA_INCOMPLETE)
  227.                 mark = TA_INCOMPLETE;
  228.             if (mark == 0) continue;
  229.             if (is_access(t)) real_t = (Symbol) designated_type(t);
  230.             else real_t = t;
  231.  
  232.             if (!is_private(real_t) ) {
  233.                 /* full declaration  of private ancestor(s) has been seen.
  234.                  * save visible declaration before updating.
  235.                  */
  236.                 private_decls_put((Private_declarations)
  237.                   private_decls(mod_name), t);
  238.                 misc_type_attributes(t) = (misc_type_attributes(t) & ~mark );
  239.             }
  240.         ENDFORDECLARED(fd1);
  241.         /* and install the use clauses that were encountered in the
  242.          * specification.
  243.          */
  244.         uds = dcl_get(DECLARED(mod_name), "$used");
  245.         if ( uds != (Symbol)0 ) {
  246.             ud = SIGNATURE(uds);
  247.             FORTUP(uds=(Symbol), ud, ft1);
  248.                 used_mods = tup_with(used_mods, (char *) uds);
  249.             ENDFORTUP(ft1);
  250.         }
  251.         /* Else the body was not found. Error was emitted already.*/
  252.     }
  253.  
  254.     /* Initialize the stacks used for label processing.*/
  255.     lab_init();
  256. }
  257.  
  258. void module_body(int nat, Node block